No se ha buscado la relacion entre habilidades cognitivas, crecimiento y salud de los huesos utilizando los datos del estudio longitudinal de la UVG y los estudios que se han realizado con datos parecidos no han sido bien investigados en paises de bajos y medianos ingresos.
Los datos utilizados para este analisis son el producto de un estudio longitudinal dise?ado por el Dr. Barry Bogin hace mas de 50 años en conjunto con el Colegio Americano de Guatemala. Ellos se propusieron a colectar datos longitudinalmente de estudiantes de todos los a?os y darle seguimiento a su crecimiento de forma anual hasta el momento en el que completaban sus estudios de bachillerato. El estudio se expandio a 6 colegios m?s a lo largo de los años y se cuenta con datos de peso, talla, IQ, pruebas de lectura y masa osea para registros comenzando en el a?o 1953.
Esta base de datos pertenece a la fundaci?n Bill and Melinda Gates, los cuales donaron los fondos necesarios para digitalizarla.
Los niños del dataset escogido tienen una estatura menor a los niños de otros paises para los mismos grupos etarios. Se estÔ buscando formas de extrapolar los datos de la base de datos a nivel nacional para poder utilizar macroindicadores para buscar una razón por la cual los niños de Guatemala son mÔs pequeños.
subjects = as.data.table(read_xlsx(path = "../data/1-Subjects sex_ID_school_DOB.xlsx"))
card1 = as.data.table(read_xlsx("../data/4-Card1.xlsx"))
card2 = as.data.table(read_xlsx("../data/5-Card2.xlsx"))En las tres bases de datos existen registros de control de digitalizacion como.
entering date: Fecha en la que los datos fueron digitalizados.User : Usuario que digitaliz? el dato.Estas variables, por ser solo de control, junto a Repetition en Card1 y Card2, que no esta presente en casi todo el conjunto de datos, seran desechadas.
En Subjects podemos encontrar las siguientes variables personales de cada sujeto de estudio.
ID: Identificador personal para cada persona involucrada en el set de datos.DOB: Fecha de nacimiento de la persona.DOB decimal: A?o de nacimiento de la persona en representacion decimal.Sex: Sexo de la persona.IdSchool 1: Identificador del colegio al que asisti? la persona.IdSchool 2: Valor booleano que representa si el sujeto ya no estudia en el colegio representado en IdSchool 1En Card1 podemos encontrar las siguientes caracteristicas fisiologicas de los sujetos de observacion.
yearCard1: A?o en el que se recopilaron los datos.gradeCard1: Grado escolar al que pertenec?a la persona.Height: Altura de la persona en centimetros.Weight: Peso de la persona en kg.Hand grip: Fuerza de la mano calculado en kg.Dental: Dentici?n piezas del sujeto. N?mero de piezas permanentes eruptadas.En Card2 podemos encontrar las siguientes caracteristicas fisiologicas de los sujetos de observacion.
yearCard2: A?o en el que se recopilaron los datos.grade Card 2: Grado escolar al que pertenec?a la persona.UAC1: Circunferencia Tricep 1UAC2: Circunferencia Tricep 2TST1: Pliegue Cut?neo Tricep 1TST2: Pliegue Cut?neo Tricep 2SSF1: Pliegue Cut?neo Subescapular 1SSF2: Pliegue Cut?neo Subescapular 2mainData = subjects
c1 = card1
c2 = card2
colnames(mainData)[1] <- "Id"
colnames(c1)[2] <- "date"
colnames(c2)[2] <- "date"
cards <- merge(c1, c2, by = c("Id", "date"))
completeData <- merge(mainData, cards, by = "Id")
completeData$age <- round(completeData$date - completeData$`DOB decimal`, 0)ggplot(completeData, aes(x = age)) +
geom_bar() +
labs(x = "Edad", y = "Frecuencia")ggplot(completeData, aes(group = age, x = age, y = Height)) +
geom_boxplot() +
labs(x = "Edad", y = "Altura (cm)")Las alturas de m?s de 250 cm no tienen sentido. Adem?s, las edades mayores a 22 a?os tienen muy pocos datos. Se decidi? removerlos:
completeData <- completeData %>%
filter(Height < 250) %>%
filter(age < 23)ggplot(completeData, aes(group = age, x = age, y = Height)) +
geom_boxplot() +
labs(x = "Edad", y = "Altura (cm)")ggplot(completeData, aes(group = age, x = age, y = Weight)) +
geom_boxplot() +
labs(x = "Edad", y = "Peso (kg)")Pesos mayores a 200 kg no tienen sentidos. Se decidi? eliminarlos:
completeData <- completeData %>%
filter(Weight < 200)ggplot(completeData, aes(group = age, x = age, y = Weight)) +
geom_boxplot() +
labs(x = "Edad", y = "Peso (kg)")for(i in 4:22){
temp <- completeData %>%
filter(age == i)
print(ggplot(temp, aes(x = Weight, y = Height)) + geom_point() +
labs(x = "Peso (kg)", y = "Altura (cm)", title = paste(i, " anos")) +
geom_smooth(method = lm, se = F))
}Solo existen 4 datos para mediciones con cuatro y veintidos a?os de edad. Se eliminar?n:
completeData <- completeData %>%
filter(age > 4) %>%
filter(age < 22)ggplot(completeData, aes(group = Dental, x = Dental, y = Height)) +
geom_boxplot() +
labs(x = "N?mero de dientes", y = "Altura (cm)")No tiene sentido que hayan ni?os tan altos sin dientes permanentes āerupcionadosā. Seg?n la Asociaci?n Dental de Am?rica, se espera que a partir de los 6-7 a?os por lo menos se hayan desarrollado los incisivos centrales. Probablemente esos ā0ās signifiquen que no fue registrado el dato. Para comprobar cu?ntos registros de ni?os mayores a?os no tienen dientes permanentes āerupcionadosā:
paste(round((nrow(filter(completeData, age > 7 & Dental == 0))
/ nrow(completeData) * 100),2), "%")## [1] "62.46 %"
M?s del 60% de los datos no tienen ese registro, por lo que no se utilizar? esta columna.
completeData <- completeData %>%
mutate(Dental = NULL)IdSchool2, que indica si se cambiaron de colegio parece tener muchos NAs. Chequear:
paste(round(nrow(filter(completeData, is.na(`IdSchool 2`))) /
nrow(completeData) * 100, 2), "%")## [1] "99.86 %"
Casi el 100% de los registros no poseen esta informaci?n. Se eliminar? esta columna. Adem?s, se eliminar?n las columnas Repetition y RepetitionCard1 ya que estas proveen poca informaci?n acerca de la altura. Es m?s, los alumnos repitentes podr?an distorsionar las predicciones.
completeData <- completeData %>%
mutate(`IdSchool 2` = NULL) %>%
mutate(Repetition = NULL) %>%
mutate(RepetitionCard1 = NULL)Visualizar los datos de pruebas de fuerza de agarre:
ggplot(completeData, aes(y = `Hand grip`, x = age, group = age)) +
geom_boxplot() +
labs(y = "fuerza de agarre (kg)", x = "Edad (a?os)")No existen registros de pruebas de fuerza de agarre en los que se superen los 100 kg de fuerza de agarre, por lo que se eliminar?n los outliers y se vuelve a graficar:
completeData <- completeData %>%
filter(`Hand grip` < 100)ggplot(completeData, aes(y = `Hand grip`, x = age, group = age)) +
geom_boxplot() +
labs(y = "fuerza de agarre (kg)", x = "Edad (a?os)")for(i in 5:21){
temp <- completeData %>%
filter(age == i)
print(ggplot(temp, aes(x = `Hand grip`)) +
geom_bar() +
labs(y = "Frecuencia",
x = "fuerza de agarre (kg)",
title = paste(i, " a?os")
)
)
}La fuerza de agarre presenta una distribuci?n aparentemente normal desde los 5 hasta los 14 a?os. Sin embargo, a partir de los 15 a?os y sobre todo entre los 17 y 19 a?os, se pueden observar claramente dos distribuciones que se traslapan. Esto indica que en estas edades la diferencia de fuerza de agarre es mucho m?s marcada entre dos grupos que no se encuentran diferenciados.
Probando agrupar por sexo:
## Warning: position_stack requires non-overlapping x intervals
## Warning: position_stack requires non-overlapping x intervals
## Warning: position_stack requires non-overlapping x intervals
## Warning: position_stack requires non-overlapping x intervals
## Warning: position_stack requires non-overlapping x intervals
## Warning: position_stack requires non-overlapping x intervals
## Warning: position_stack requires non-overlapping x intervals
## Warning: position_stack requires non-overlapping x intervals
Se observa claramente que a partir de los 15 a?os, los hombres tienen una distribuci?n normal (aparentemente) con una media de fuerza de agarre mayor al de las mujeres. Por lo tanto, debemos considerarlos como dos grupos claramente distintos a partir de esa edad.
Se eliminar?n otras variables poco ?tiles como entering date, entering data y User. Tambi?n se eliminar?n DOB y DOB decimal debido a que ya se calcul? la edad en cada registro.
completeData <- completeData %>%
mutate(`entering date` = NULL) %>%
mutate(`entering data` = NULL) %>%
mutate(User.x = NULL) %>%
mutate(User.y = NULL) %>%
mutate(DOB = NULL) %>%
mutate(`DOB decimal` = NULL)Se evalur? la factibilidad de realizar un an?lisis de componentes principales utilizando la base de datos unificada del estudio.
pafDatos<-paf(as.matrix(completeData[,5:16]))
pafDatos$KMO## [1] 0.85819
pafDatos$Bartlett## [1] 2421648
summary(pafDatos)## $KMO
## [1] 0.85819
##
## $MSA
## MSA
## gradeCard1 0.83601
## Height 0.92160
## Weight 0.90312
## Hand grip 0.93608
## grade Card 2 0.83729
## UAC1 cm 0.80366
## UAC2 cm 0.80384
## TST1 mm 0.79716
## TST2 mm 0.79823
## SSF1 mm 0.82861
## SSF2 mm 0.82803
## age 0.97768
##
## $Bartlett
## [1] 2421648
##
## $Communalities
## Initial Communalities Final Extraction
## gradeCard1 0.98864 0.86971
## Height 0.91943 0.89380
## Weight 0.94777 0.91474
## Hand grip 0.87237 0.81604
## grade Card 2 0.98820 0.86287
## UAC1 cm 0.99593 0.57536
## UAC2 cm 0.99593 0.57580
## TST1 mm 0.95257 0.87040
## TST2 mm 0.95345 0.87526
## SSF1 mm 0.96473 0.85979
## SSF2 mm 0.96527 0.86265
## age 0.87779 0.87569
##
## $Factor.Loadings
## [,1] [,2]
## gradeCard1 0.83186 0.421571
## Height 0.86609 0.379059
## Weight 0.94768 0.128994
## Hand grip 0.79659 0.426004
## grade Card 2 0.82894 0.419198
## UAC1 cm 0.75193 -0.099771
## UAC2 cm 0.75237 -0.098677
## TST1 mm 0.62373 -0.693797
## TST2 mm 0.62838 -0.693102
## SSF1 mm 0.74180 -0.556351
## SSF2 mm 0.74499 -0.554659
## age 0.83283 0.426710
##
## $RMS
## [1] 0.066734
cortest.bartlett(completeData[,5:16])## $chisq
## [1] 2421648
##
## $p.value
## [1] 0
##
## $df
## [1] 66
Como se puede observar se obtuvo un KMO de 0.86 y un coeficiente de Bartlett muy elevado 2421661 por lo que parece que un analisis de componentes principales es una buena idea. Considerando que el valor P indicado es de 0.
kable(cor(completeData[,5:16],use = "pairwise.complete.obs"))| gradeCard1 | Height | Weight | Hand grip | grade Card 2 | UAC1 cm | UAC2 cm | TST1 mm | TST2 mm | SSF1 mm | SSF2 mm | age | |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| gradeCard1 | 1.00000 | 0.85641 | 0.80226 | 0.79473 | 0.99407 | 0.52631 | 0.52727 | 0.25662 | 0.26096 | 0.38687 | 0.39030 | 0.91093 |
| Height | 0.85641 | 1.00000 | 0.91493 | 0.89282 | 0.85280 | 0.58126 | 0.58223 | 0.29189 | 0.29666 | 0.42382 | 0.42748 | 0.88920 |
| Weight | 0.80226 | 0.91493 | 1.00000 | 0.87762 | 0.79880 | 0.67957 | 0.68008 | 0.49164 | 0.49593 | 0.65189 | 0.65519 | 0.82843 |
| Hand grip | 0.79473 | 0.89282 | 0.87762 | 1.00000 | 0.79095 | 0.56448 | 0.56525 | 0.17862 | 0.18268 | 0.36034 | 0.36341 | 0.82868 |
| grade Card 2 | 0.99407 | 0.85280 | 0.79880 | 0.79095 | 1.00000 | 0.52445 | 0.52540 | 0.25646 | 0.26080 | 0.38606 | 0.38955 | 0.90778 |
| UAC1 cm | 0.52631 | 0.58126 | 0.67957 | 0.56448 | 0.52445 | 1.00000 | 0.99796 | 0.49499 | 0.49778 | 0.55661 | 0.55874 | 0.53125 |
| UAC2 cm | 0.52727 | 0.58223 | 0.68008 | 0.56525 | 0.52540 | 0.99796 | 1.00000 | 0.49431 | 0.49728 | 0.55615 | 0.55846 | 0.53227 |
| TST1 mm | 0.25662 | 0.29189 | 0.49164 | 0.17862 | 0.25646 | 0.49499 | 0.49431 | 1.00000 | 0.97528 | 0.81732 | 0.81671 | 0.23912 |
| TST2 mm | 0.26096 | 0.29666 | 0.49593 | 0.18268 | 0.26080 | 0.49778 | 0.49728 | 0.97528 | 1.00000 | 0.81943 | 0.82168 | 0.24343 |
| SSF1 mm | 0.38687 | 0.42382 | 0.65189 | 0.36034 | 0.38606 | 0.55661 | 0.55615 | 0.81732 | 0.81943 | 1.00000 | 0.98156 | 0.39275 |
| SSF2 mm | 0.39030 | 0.42748 | 0.65519 | 0.36341 | 0.38955 | 0.55874 | 0.55846 | 0.81671 | 0.82168 | 0.98156 | 1.00000 | 0.39630 |
| age | 0.91093 | 0.88920 | 0.82843 | 0.82868 | 0.90778 | 0.53125 | 0.53227 | 0.23912 | 0.24343 | 0.39275 | 0.39630 | 1.00000 |
En la matriz de correlaci?n observamos que algunas variables se encuentran relacionadas por lo que se proceder? a realizar el analisis de componentes principales para intentar reducir el dataset.
compPrinc<-prcomp(completeData[,5:16], scale = T)
compPrinc## Standard deviations (1, .., p=12):
## [1] 2.747921 1.616220 0.945791 0.616499 0.530070 0.331693 0.288965
## [8] 0.191409 0.158107 0.134577 0.076768 0.045138
##
## Rotation (n x k) = (12 x 12):
## PC1 PC2 PC3 PC4 PC5 PC6
## gradeCard1 -0.30401 -0.269759 -0.17414549 0.386405 -0.234315 0.2859950
## Height -0.31565 -0.240520 -0.08540084 -0.166256 0.327864 -0.3033746
## Weight -0.34461 -0.082917 -0.06779067 -0.325564 0.198734 0.0307808
## Hand grip -0.29344 -0.277911 0.00035571 -0.438306 0.308140 0.4495349
## grade Card 2 -0.30322 -0.268947 -0.17530638 0.394565 -0.241555 0.3019985
## UAC1 cm -0.28730 0.071510 0.63308014 0.081038 -0.067667 -0.0191125
## UAC2 cm -0.28745 0.070725 0.63274012 0.081285 -0.067745 -0.0204074
## TST1 mm -0.22839 0.437747 -0.14812711 0.290244 0.381407 0.0295550
## TST2 mm -0.22994 0.436489 -0.14862260 0.285589 0.373284 0.0265191
## SSF1 mm -0.27188 0.351776 -0.17275539 -0.296548 -0.416570 -0.0088605
## SSF2 mm -0.27294 0.350309 -0.17242592 -0.293925 -0.412166 -0.0111611
## age -0.30418 -0.272423 -0.14931864 0.126313 -0.086110 -0.7275829
## PC7 PC8 PC9 PC10 PC11
## gradeCard1 0.0924795 0.00370190 -0.00112969 0.0021799 7.1407e-01
## Height 0.6006008 -0.49705760 -0.01485158 -0.0059114 -2.2324e-03
## Weight 0.2626976 0.80868119 0.01339779 0.0130978 -3.7465e-03
## Hand grip -0.5342205 -0.24920449 0.00010806 -0.0041129 -1.0930e-03
## grade Card 2 0.0989190 -0.00010443 -0.00049563 -0.0020808 -6.9998e-01
## UAC1 cm 0.0049942 -0.01289632 -0.00370285 0.0029086 -1.8120e-04
## UAC2 cm 0.0059030 -0.01471850 0.00258083 -0.0029117 2.0805e-04
## TST1 mm -0.0955495 0.00196594 -0.68737431 -0.1485430 1.2609e-06
## TST2 mm -0.0846200 -0.02993082 0.69407030 0.1520369 -1.7148e-04
## SSF1 mm 0.0144062 -0.12416804 -0.15581519 0.6863130 -1.2243e-03
## SSF2 mm 0.0174727 -0.10826089 0.14516225 -0.6953701 3.0080e-03
## age -0.4996768 0.09182093 0.00324789 0.0022928 -9.7970e-03
## PC12
## gradeCard1 -2.7952e-04
## Height -1.4022e-03
## Weight 8.6583e-04
## Hand grip 3.2516e-04
## grade Card 2 9.3384e-05
## UAC1 cm -7.0699e-01
## UAC2 cm 7.0720e-01
## TST1 mm 2.6874e-03
## TST2 mm -2.2652e-03
## SSF1 mm 3.4936e-03
## SSF2 mm -3.5161e-03
## age -4.7521e-04
summary(compPrinc)## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 2.748 1.616 0.9458 0.6165 0.5301 0.33169 0.28897
## Proportion of Variance 0.629 0.218 0.0745 0.0317 0.0234 0.00917 0.00696
## Cumulative Proportion 0.629 0.847 0.9215 0.9532 0.9766 0.98574 0.99269
## PC8 PC9 PC10 PC11 PC12
## Standard deviation 0.19141 0.15811 0.13458 0.07677 0.04514
## Proportion of Variance 0.00305 0.00208 0.00151 0.00049 0.00017
## Cumulative Proportion 0.99575 0.99783 0.99934 0.99983 1.00000
compPrincPCA<-PCA(completeData[,5:16],ncp=ncol(completeData[,5:16]), scale.unit = T)Al realizar el anĆ”lisis de componentes principales observamos que realmente no se redujo el dataset de ninguna forma al evaluar los componentes principales. Los indicadores utilizados como KMO y Bartlett parecen indicar que se puede realizar un anĆ”lisis de componentes principales pero como se puede observar en las comunalidades la mayorĆa de las variables seleccionadas para el anĆ”lisis del PCA explican su variabilidad correctamente. Por lo que realizar un anĆ”lisis de componentes principales solo reordena las variables de la mĆ”s variable a la menos variable. Esto es innecesario por lo que no se realizarĆ” anĆ”lisis de componentes principales y se trabajarĆ” con las variables del set de datos tal y como estĆ”n.
Ahora que hemos unido ambos Cards, eliminado outliers y desechado variables innecesari, nuestro conjunto de datos est? listo para entrar a un analisis de Clustering.
Antes de agrupar los datos, necesitamos averiguar cual es la cantidad optima de grupos. Para averiguar este numero, utilizaremos el diagrama de codo del metodo de Ward.
library(factoextra)
library(cluster)
cluster = completeData[,c('Sex','gradeCard1','Height','Weight','Hand grip','UAC1 cm','TST1 mm','SSF1 mm','age')]
cluster$Sex = as.factor(cluster$Sex)
cluster$Sex = as.numeric(cluster$Sex)
set.seed(12)
wss <- (nrow(cluster[,c()])-1)*sum(apply(cluster[,1:ncol(cluster)],2,var))
for (i in 2:10)
wss[i] <- sum(kmeans(cluster[,1:ncol(cluster)], centers=i)$withinss)
plot(2:
10, wss[c(2:10)], type="b", xlab="Number of Cluster", ylab="Squares Summatory", main = "Diagrama de Codo")Con ayuda del diagrama de codo, definiremos 4 como la cantidad de clusters a realizar. Utilizaremos la tecnica de k-medias para crear los grupos.
require("fpc")
library(cluster)
set.seed(90)
km = kmeans(cluster, 4)
cluster$grupo<-km$cluster
completeData$grupo = km$cluster
g1 = completeData[cluster$grupo == 1,]
g2 = completeData[cluster$grupo == 2,]
g3 = completeData[cluster$grupo == 3,]
g4 = completeData[cluster$grupo == 4,]
plotcluster(cluster[,c(1:9)],cluster$grupo)Ahora que ya tenemos los distintos grupos, hagamos un rapido analisis sobre las distribuciones de cada variable dentro de los grupos
ggplot(data = completeData, aes(group = grupo, y = age, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Edad") + ylim(c(0,25))Podemos ver que esta bastante definido que los grupos estan muy bien definidos conforme a la edad de las personas. Aun asi, notese que en cada grupo la media esta bastante centrada en los boxplots excepto por el primer grupo.
ggplot(data = completeData, aes(group = grupo, y = Height, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Altura (cm)") + ylim(c(100,200))En la altura se ve un comportamiento muy similar con la edad, lo unico curioso es que aqui si se observa que las alturas medias estan bastante centradas dentro de los boxplots.
ggplot(data = completeData, aes(group = grupo, y = Weight, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Peso (kg)") + ylim(c(0,100))En el peso podemos ver el mismo comportamiento analizado anteriormente. Pero a diferencia de la edad y la altura, pareciera que el peso var?a de forma distinta dentro de cada grupos.
ggplot(data = completeData, aes(group = grupo, y = `Hand grip`, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Hand grip") + ylim(c(0,70))En la fuerza de la mano tambien tiene el mismo comportamiento que los anteriores, pero se puede ver que el mismo varia mucho mas en el grupo 4, que es el grupo con las personas mas adultas.
ggplot(data = completeData, aes(group = grupo, y = gradeCard1, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Grado Escolar")Nuevamente el patron es notable. La forma del boxplot del primero grupo puede ser devido a que los estudios primarios llegan hasta el numero 16 y los secundarios empiezan en 21. Podria decirse que aqui se encuntran las personas en estudios basicos. En el segundo grupo estan los grados mas peque?os, podriamos llamarlos el primer ciclo primario. En el tercer grupo estan los del segundo ciclo primario y en el cuarto grupo estan los bachilleres.
ggplot(data = completeData, aes(group = grupo, y = `UAC1 cm`, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("UAC1 cm") + ylim(c(10,40))En la circuferencia de los triceps tambien siguen el patron encontrado, lo cual tiene sentido ya que los musculos tambien crecen conforme la edad.
ggplot(data = completeData, aes(group = grupo, y = `TST1 mm`, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("TST1 mm") + ylim(c(0,35))La variabilidad en el pliege cutaneo de los triceps es muy desigual entre los grupos, y muchos de los grupos comparten similitudes en los datos. Curiosamente estos boxplots no coinciden con los patrones entre grupos encontrados anteriormente.
ggplot(data = completeData, aes(group = grupo, y = `SSF1 mm`, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("SSF1 mm") + ylim(c(0,35))En el pliegue subescapular pareciera que siguen el patron encontrado anteriormete. Pero el primer grupo y el cuarto son muy similares, aunque la media del primer grupo est? por arriba de la media del cuarto. Sera esto debido a la cantidad de hombres y mujeres dentro del grupo?
barplot(prop.table(table(g1$Sex)))En el grupo 1 hay alrededor de un 20% mas mujeres que hombres.
barplot(prop.table(table(g2$Sex)))En el grupo 2 hay alrededor de 10% mas hombres que mujeres.
barplot(prop.table(table(g3$Sex)))En el grupo 3 hay alrededor de 20% mas hombres que mujeres.
barplot(prop.table(table(g4$Sex)))En el grupo 4, en su mayoria son hombres. Esto podria dar lugar al porque en el grupo 1 se encuentran mas mujeres que hombres.
ggplot(g1, aes(group = age, x = age, y = Height)) +
geom_boxplot() +
labs(x = "Edad", y = "Altura (cm)")Se puede ver que en el grupo 1 el aumento que las alturas mayores sen encuentran entre los 15 y 16 con alturas promedio de 155cm. Esto puede ser debido a la gran cantidad de mujeres presentes en el grupo.
ggplot(g2, aes(group = age, x = age, y = Height)) +
geom_boxplot() +
labs(x = "Edad", y = "Altura (cm)")En el grupo 2 estan las personas mas juvenes, se puede ver como cambia drasticamente la altura en los ni?os y se empieza a estabilizar a los 10 a?os.
ggplot(g3, aes(group = age, x = age, y = Height)) +
geom_boxplot() +
labs(x = "Edad", y = "Altura (cm)")En el grupo 3 se puede observar como las personas estan entrando a la adolescencia y empiezan a tener cambios drasticos en la altura entre los 11 y 14 a?os.
ggplot(g4, aes(group = age, x = age, y = Height)) +
geom_boxplot() +
labs(x = "Edad", y = "Altura (cm)")En el grupo 4 tenemos a las personas mas altas de todo el conjunto de datos.
ggplot(g1, aes(y = `Hand grip`, x = age, group = age)) +
geom_boxplot() +
labs(y = "fuerza de agarre (kg)", x = "Edad (anos)")En el grupo 1, el de los jovenes, se ve que obtienen mas fuerza entre mas crecen, pero la fuerza deja de aumentar considerablemente despues de los 15 a?os, esto puede ser debido a la alta cantidad de mujeres, suponiendo que las mujeres tienen menos fuerza en las manos que los hombres.
ggplot(g2, aes(y = `Hand grip`, x = age, group = age)) +
geom_boxplot() +
labs(y = "fuerza de agarre (kg)", x = "Edad (anos)")En el grupo 2 estan las personas mas debiles, se puede ver como su fuerza va en promedio de 6 a 12 kg de fuerza de agarre
ggplot(g3, aes(y = `Hand grip`, x = age, group = age)) +
geom_boxplot() +
labs(y = "fuerza de agarre (kg)", x = "Edad (anos)")En el grupo 3 se ve como las personas van obteniendo mas fuerza conforme crecen y dejan de ser ni?os
ggplot(g4, aes(y = `Hand grip`, x = age, group = age)) +
geom_boxplot() +
labs(y = "fuerza de agarre (kg)", x = "Edad (anos)")En el grupo 4 se encuentran las personas mas fuertes, mas adultas y en su mayoria hombres. Se puede apreciar tambien las grandes variaciones que se encuentran, lo cual contrasta lo analizado en la exploracion anterior, en la cual se concluyo que en altas edades hay bastantes personas debiles como personas fuertes.
ggplot(g1, aes(group = age, x = age, y = Weight)) +
geom_boxplot() +
labs(x = "Edad", y = "Peso (kg)")En el grupo 1 podemos ver que el promedio de peso cae levemente durante la epoca de pubertad pero se mantiene bastante constante. En lo que se observa cambio es en la variabilidad de los pesos. Los peso promedio esta por los 50 kg.
ggplot(g2, aes(group = age, x = age, y = Weight)) +
geom_boxplot() +
labs(x = "Edad", y = "Peso (kg)")En el grupo 2 se ve como los ni?os aumentan de peso gradualmente durante su crecimiento. Aqui se encuentran las personas menos pesadas.
ggplot(g3, aes(group = age, x = age, y = Weight)) +
geom_boxplot() +
labs(x = "Edad", y = "Peso (kg)")En el grupo 3 puede verse que estan las personas mas pesadas de 5, 6 y 7 a?os, edades que tambien estan presente en el grupo 2. Luego se puede apreciar como las personas siguen aumentando de peso conforme van creciendo.
ggplot(g4, aes(group = age, x = age, y = Weight)) +
geom_boxplot() +
labs(x = "Edad", y = "Peso (kg)")En el grupo 4 estan las personas mas pesadas de todas. desde ni?os hasta adultos.
De primero removeremos las columnas que indispensables encontradas en el analisis exploratorio (Id, grade Card 2, UAC2, TST2, SSF2 ).
completeData = completeData[,c("Sex","IdSchool 1","gradeCard1","Height","Weight","Hand grip","UAC1 cm","TST1 mm","SSF1 mm","age","grupo")]
colnames(completeData) = c("sex","school","grade","height","weight","hand_grip","UAC","TST","SSF","age","grupo")
head(completeData)## sex school grade height weight hand_grip UAC TST SSF age grupo
## 1 M 1 25 180.0 55.8 45 0 5 9 18 1
## 2 M 1 25 171.5 59.5 50 0 4 7 18 1
## 3 F 1 25 173.0 61.3 29 0 8 9 17 1
## 4 M 1 25 164.5 50.8 37 0 4 9 17 4
## 5 F 1 24 150.5 49.5 26 0 14 17 17 4
## 6 F 1 25 151.0 51.3 27 0 11 15 18 4
Se redujo la cantidad de variables y se renombraron para facilidad del analista.
datos = completeData
datos$sex = as.factor(datos$sex)
datos$sex = as.numeric(datos$sex)
#Obtener matriz de correlacion
cormat = round(cor(datos,use = "complete.obs"),2)
#Reordenar matriz de correlacion
reorder_cormat <- function(cormat){
# Use correlation between variables as distance
dd <- as.dist((1-cormat)/2)
hc <- hclust(dd)
cormat <-cormat[hc$order, hc$order]
}
cormat = reorder_cormat(cormat)
#Obtener triangulo superior
get_upper_tri = function(cormat){
cormat[lower.tri(cormat)] = NA
return(cormat)
}
upper_tri = get_upper_tri(cormat)
#Correlacion como heatmap
require(reshape2)## Loading required package: reshape2
##
## Attaching package: 'reshape2'
## The following objects are masked from 'package:data.table':
##
## dcast, melt
melted_cormat = melt(upper_tri, na.rm = T)
require(ggplot2)
ggheatmap = ggplot(data = melted_cormat, aes(x=Var1, y=Var2, fill = value)) + geom_tile(color = "white") + scale_fill_gradient2(low = "blue",high = "red",mid = "white", midpoint = 0, limit = c(-1,1), space = "Lab", name="Correlacion") + theme_minimal() + theme(axis.text.x = element_text(angle = 90, vjust = 1,hjust = 1)) + coord_fixed()
ggheatmap +
geom_text(aes(Var2, Var1, label = value), color = "black", size = 4) +
theme(
axis.title.x = element_blank(),
axis.title.y = element_blank(),
panel.grid.major = element_blank(),
panel.border = element_blank(),
panel.background = element_blank(),
axis.ticks = element_blank(),
legend.justification = c(1, 0),
legend.position = c(0.6, 0.7),
legend.direction = "horizontal")+
guides(fill = guide_colorbar(barwidth = 7, barheight = 1,
title.position = "top", title.hjust = 0.5))Se puede ver que nuestras variables fisicas de los individuos se relacionan bastante bien. Las variables en las cuales no se nota una relacion con cualquier otra son sex y school. Eliminemoslas y corramos el mismo analisis.
datos = datos[,c("grade","height","weight","hand_grip","UAC","TST","SSF","age")]
#Obtener matriz de correlacion
cormat = round(cor(datos,use = "complete.obs"),2)
#Reordenar matriz de correlacion
reorder_cormat <- function(cormat){
# Use correlation between variables as distance
dd <- as.dist((1-cormat)/2)
hc <- hclust(dd)
cormat <-cormat[hc$order, hc$order]
}
cormat = reorder_cormat(cormat)
#Obtener triangulo superior
get_upper_tri = function(cormat){
cormat[lower.tri(cormat)] = NA
return(cormat)
}
upper_tri = get_upper_tri(cormat)
#Correlacion como heatmap
require(reshape2)
melted_cormat = melt(upper_tri, na.rm = T)
require(ggplot2)
ggheatmap = ggplot(data = melted_cormat, aes(x=Var1, y=Var2, fill = value)) + geom_tile(color = "white") + scale_fill_gradient2(low = "blue",high = "red",mid = "white", midpoint = 0, limit = c(-1,1), space = "Lab", name="Correlacion") + theme_minimal() + theme(axis.text.x = element_text(angle = 90, vjust = 1,hjust = 1)) + coord_fixed()
ggheatmap +
geom_text(aes(Var2, Var1, label = value), color = "black", size = 4) +
theme(
axis.title.x = element_blank(),
axis.title.y = element_blank(),
panel.grid.major = element_blank(),
panel.border = element_blank(),
panel.background = element_blank(),
axis.ticks = element_blank(),
legend.justification = c(1, 0),
legend.position = c(0.6, 0.7),
legend.direction = "horizontal")+
guides(fill = guide_colorbar(barwidth = 7, barheight = 1,
title.position = "top", title.hjust = 0.5))Ahora removeremos las variables independientes que se relaciones entre ellas para evitar la multicolinearidad. Entre hand_grip y height hay una relacion del 89%. Debido a que la ultura y el peso pueden tomarse como co-variables se removera height.
Entre age y grade hay una alta y obvia relacion del 91%, nos quedaremos con age ya que tiene una mayor relacion con weight.
Entre TST Y SSF existe una relacion del 82%, se escogera a SSF para el modelo por su mayor relacion con weight.
datos = datos[,c("weight","hand_grip","UAC","SSF","age")]
#Obtener matriz de correlacion
cormat = round(cor(datos,use = "complete.obs"),2)
#Reordenar matriz de correlacion
reorder_cormat <- function(cormat){
# Use correlation between variables as distance
dd <- as.dist((1-cormat)/2)
hc <- hclust(dd)
cormat <-cormat[hc$order, hc$order]
}
cormat = reorder_cormat(cormat)
#Obtener triangulo superior
get_upper_tri = function(cormat){
cormat[lower.tri(cormat)] = NA
return(cormat)
}
upper_tri = get_upper_tri(cormat)
#Correlacion como heatmap
require(reshape2)
melted_cormat = melt(upper_tri, na.rm = T)
require(ggplot2)
ggheatmap = ggplot(data = melted_cormat, aes(x=Var1, y=Var2, fill = value)) + geom_tile(color = "white") + scale_fill_gradient2(low = "blue",high = "red",mid = "white", midpoint = 0, limit = c(-1,1), space = "Lab", name="Correlacion") + theme_minimal() + theme(axis.text.x = element_text(angle = 90, vjust = 1,hjust = 1)) + coord_fixed()
ggheatmap +
geom_text(aes(Var2, Var1, label = value), color = "black", size = 4) +
theme(
axis.title.x = element_blank(),
axis.title.y = element_blank(),
panel.grid.major = element_blank(),
panel.border = element_blank(),
panel.background = element_blank(),
axis.ticks = element_blank(),
legend.justification = c(1, 0),
legend.position = c(0.6, 0.7),
legend.direction = "horizontal")+
guides(fill = guide_colorbar(barwidth = 7, barheight = 1,
title.position = "top", title.hjust = 0.5))